home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / weak.t < prev    next >
Text File  |  1988-05-02  |  11KB  |  318 lines
  1. (herald weak
  2.   (env tsys))
  3.  
  4. ;;; No more 'simultaneous access on weak' errors.
  5.  
  6. ;;; Weak sets and weak alists
  7.  
  8. ;;; (MAKE-WEAK-SET . ELTS)
  9. ;;; (WEAK-SET-MEMBER? S X)
  10. ;;; (MAP-WEAK-SET F S)
  11. ;;; (WALK-WEAK-SET F S)
  12. ;;; (ADD-TO-WEAK-SET! S X)
  13. ;;; (REMOVE-FROM-WEAK-SET! S X)
  14. ;;; (WEAK-SET-POP! S)
  15. ;;; (WEAK-SET-EMPTY? S)
  16. ;;; (WEAK-SET->LIST S)
  17.  
  18. ;;; (MAKE-WEAK-ALIST)
  19. ;;; (WEAK-ALIST-PUSH! S X Y)
  20. ;;; (WEAK-ALIST-MOVE FROM TO PREDICATE)
  21. ;;; (WEAK-ALIST-MERGE FROM TO)
  22.  
  23. ;;; Weak Sets
  24.  
  25. (define (make-weak-set . elts)
  26.   (let* ((elts (copy-list elts))   ; Safety...
  27.          (wk (make-vector-extend header/weak-set 0 1)))
  28.     (set (weak-set-elements wk) elts)
  29.     (clear-weak-semaphore wk)
  30.     wk))
  31.  
  32. (define-local-syntax (define-weak-set-proc spec set-var elts-var body)
  33.   `(define ,spec
  34.      (let* ((already-set? (test-and-set-semaphore ,set-var))
  35.             (,elts-var (weak-set-elements ,set-var))
  36.             (res ,body))
  37.        (if (not already-set?) (clear-weak-semaphore ,set-var))
  38.        res)))
  39.  
  40. (define-weak-set-proc (weak-set-member? set member) set elts
  41.   (memq? member elts))
  42.  
  43. (define-weak-set-proc (weak-set-empty? set) set elts
  44.   (null? elts))
  45.  
  46. (define-weak-set-proc (map-weak-set f set) set elts
  47.   (map1 f elts))
  48.  
  49. (define-weak-set-proc (walk-weak-set f set) set elts
  50.   (walk1 f elts))
  51.  
  52. (define-weak-set-proc (weak-set->list set) set elts
  53.   (copy-list elts))
  54.  
  55. (define-local-syntax (define-weak-set-modifier spec set-var elts-var body)
  56.   `(define ,spec
  57.      (let* ((already-set? (test-and-set-semaphore ,set-var))
  58.             (,elts-var (weak-set-elements ,set-var)))
  59.        (set (weak-set-elements ,set-var) ,body)
  60.        (if (not already-set?) (clear-weak-semaphore ,set-var))
  61.        ,set-var)))
  62.  
  63. (define-weak-set-modifier (add-to-weak-set! set member) set elts
  64.   (if (memq? member elts) elts (cons member elts)))
  65.  
  66. (define-weak-set-modifier (remove-from-weak-set! set member) set elts
  67.   (delq! member elts))
  68.  
  69. (define (weak-set-pop! set)
  70.   (let* ((already-set? (test-and-set-semaphore set))
  71.          (elts (weak-set-elements set)))
  72.     (cond ((null? elts)     
  73.            (if (not already-set?) (clear-weak-semaphore set))
  74.            nil)
  75.           (else
  76.            (let ((elt (car elts)))
  77.              (set (weak-set-elements set) (cdr elts))
  78.              (if (not already-set?) (clear-weak-semaphore set))
  79.              elt)))))
  80.  
  81. (define-handler weak-set
  82.   (object nil
  83. ;++    ((print self stream)
  84. ;++     (format stream "#{Weak-set~_~D}" (object-hash self)))
  85.     ((crawl-exhibit self)
  86.      (exhibit-standard-extend self 1 0 0))
  87.     ((maybe-crawl-component self command)
  88.      (cond ((and (fixnum? command)
  89.                  (fx= command 0))
  90.             (crawl-push (extend-pointer-elt self command)))
  91.            (else nil)))
  92.     ((print-type-string self) "Weak-set")))
  93.  
  94.  
  95. ;;; Weak alists
  96.  
  97. (define (make-weak-alist)
  98.   (let ((wk (make-vector-extend header/weak-alist 0 1)))
  99.     (set (weak-alist-elements wk) empty-weak-alist-vector)
  100.     (clear-weak-semaphore wk)
  101.     wk))
  102.  
  103. (define (weak-alist-push! alist key val)
  104.   (let* ((already-set? (test-and-set-semaphore alist))
  105.          (vec (weak-alist-elements alist))
  106.          (len (vector-length vec))
  107.          (new (get-weak-alist-vector (fx+ len 2))))
  108.     (vector-replace new vec len)
  109.     (return-weak-alist-vector vec)
  110.     (set (vref new len) key)
  111.     (set (vref new (fx+ 1 len)) val)
  112.     (set (weak-alist-elements alist) new)
  113.     (if (not already-set?) (clear-weak-semaphore alist))
  114.     (return)))
  115.  
  116. ;;; Move pairs from FROM to TO if (PREDICATE <key>) is true.
  117.  
  118. (define (weak-alist-move from to predicate)
  119.   (let ((from-already-set? (test-and-set-semaphore from))
  120.         (to-already-set? (test-and-set-semaphore to)))
  121.     (let ((from-vec (weak-alist-elements from))
  122.           (to-vec (weak-alist-elements to)))
  123.       (let ((new-to (get-weak-alist-vector (fx+ (vector-length to-vec)
  124.                                                 (vector-length from-vec))))) 
  125.         (vector-replace new-to to-vec (vector-length to-vec))
  126.         (return-weak-alist-vector to-vec)
  127.         (iterate loop ((fi 0) (nfi 0) (ti (vector-length to-vec)))
  128.           (cond ((fx>= fi (vector-length from-vec))
  129.                  (set (weak-alist-elements from)
  130.                       (maybe-shrink-weak-alist-vector from-vec nfi))
  131.                  (set (weak-alist-elements to)
  132.                       (maybe-shrink-weak-alist-vector new-to ti)))
  133.                 ((predicate (vref from-vec fi))
  134.                  (set (vref new-to ti) (vref from-vec fi))
  135.                  (set (vref new-to (fx+ 1 ti)) (vref from-vec (fx+ 1 fi)))
  136.                  (loop (fx+ fi 2) nfi (fx+ ti 2)))
  137.                 ((fx= fi nfi)
  138.                  (loop (fx+ fi 2) (fx+ nfi 2) ti))
  139.                 (else
  140.                  (set (vref from-vec nfi) (vref from-vec fi))
  141.                  (set (vref from-vec (fx+ 1 nfi)) (vref from-vec (fx+ 1 fi)))
  142.                  (loop (fx+ fi 2) (fx+ nfi 2) ti))))
  143.         (if (not from-already-set?) (clear-weak-semaphore from))
  144.         (if (not to-already-set?) (clear-weak-semaphore to))
  145.         (return)))))
  146.  
  147. ;;; Move all pairs from FROM to TO
  148.  
  149. (define (weak-alist-merge from to)
  150.   (let ((from-already-set? (test-and-set-semaphore from))
  151.         (to-already-set? (test-and-set-semaphore to)))
  152.     (let ((from-vec (weak-alist-elements from))
  153.           (to-vec (weak-alist-elements to)))
  154.       (let ((new-vec (get-weak-alist-vector (fx+ (vector-length from-vec) 
  155.                                                  (vector-length to-vec)))))
  156.         (vector-replace new-vec to-vec (vector-length to-vec))
  157.         (do ((i 0 (fx+ i 1)))
  158.             ((fx>= i (vector-length from-vec)))
  159.           (set (vref new-vec (fx+ i (vector-length to-vec)))
  160.                (vref from-vec i)))
  161.         (set (weak-alist-elements from) empty-weak-alist-vector)
  162.         (set (weak-alist-elements to) new-vec)
  163.         (return-weak-alist-vector from-vec)
  164.         (return-weak-alist-vector to-vec)
  165.         (if (not from-already-set?) (clear-weak-semaphore from))
  166.         (if (not to-already-set?)   (clear-weak-semaphore to))
  167.         (return)))))
  168.  
  169. (define (maybe-shrink-weak-alist-vector vec size)
  170.   (if (fx> (vector-length vec) size)
  171.       (let ((new (get-weak-alist-vector size)))
  172.         (vector-replace new vec size)
  173.         (return-weak-alist-vector vec)
  174.         new)
  175.       vec))
  176.  
  177. (define-handler weak-alist
  178.   (object nil
  179. ;++    ((print self stream)
  180. ;++     (format stream "#{Weak-alist~_~D}" (object-hash self)))
  181.     ((crawl-exhibit self)
  182.      (exhibit-standard-extend self 1 0 0))
  183.     ((maybe-crawl-component self command)
  184.      (cond ((and (fixnum? command)
  185.                  (fx= command 0))
  186.             (crawl-push (extend-pointer-elt self command)))
  187.            (else nil)))
  188.     ((print-type-string self) "Weak-alist")))
  189.  
  190. ;;; weak-alist pools
  191.  
  192. (define empty-weak-alist-vector (make-vector 0))
  193.  
  194. ;(define impure-weak-alist-pool-vec
  195. ;  (vector-fill (make-vector 256) nil))  ;;; bigger than number of modules
  196. ;                                        ;;; linked or suspended
  197. ;
  198. ;(define impure-weak-alist-pool
  199. ;  (object (lambda (x)
  200. ;            (vref impure-weak-alist-pool-vec x))
  201. ;    ((setter self)
  202. ;     (lambda (x val)
  203. ;       (set (vref impure-weak-alist-pool-vec x) val)))
  204. ;    ((identification self) 'impure-weak-alist-pool)))
  205. ;
  206. ;(define impure-weak-alist-pool-vec
  207. ;  (make-vector 256))
  208. ;
  209. ;(define (heap-weak-alist-pool x)
  210. ;  (vref heap-weak-alist-pool-vec x))
  211. ;
  212. ;(define (initialize-weak-alist-pool) 
  213. ;  (do ((i 0 (fx+ i 1)))
  214. ;      ((fx>= i 256))
  215. ;    (set (vref impure-weak-alist-pool i)
  216. ;         (make-weak-alist-vector-pool i)))
  217. ;  (return))
  218. ;
  219. ;(define (make-weak-alist-vector-pool size)
  220. ;  (make-pool `(weak-alist-vector-pool ,size)
  221. ;             (lambda () (make-vector (fx* size 2)))
  222. ;             1
  223. ;             vector?))
  224. ;
  225. ;(define (get-weak-alist-vector size)
  226. ;  (cond ((fx= 0 size)
  227. ;         empty-weak-alist-vector)
  228. ;        ((impure-weak-alist-pool (fx/ size 2))
  229. ;         => (lambda (vec)
  230. ;              (set (impure-weak-alist-pool (fx/ size 2))
  231. ;                   (vref vec 0))
  232. ;              vec))
  233. ;        (else
  234. ;         (obtain-from-pool (heap-weak-alist-pool (fx/ size 2))))))
  235. ;
  236. ;(define (return-weak-alist-vector vec)
  237. ;  (let ((len (vector-length vec)))
  238. ;    (cond ((fx= 0 len))
  239. ;          ((points-to-initial-impure-memory? vec)
  240. ;           (vector-fill vec 0)
  241. ;           (modify (impure-weak-alist-pool (fx/ len 2))
  242. ;                   (lambda (old)
  243. ;                     (set (vref vec 0) old)
  244. ;                     vec)))
  245. ;          (else
  246. ;           (return-to-pool (heap-weak-alist-pool (fx/ len 2)) vec))))
  247. ;    (return)))
  248.  
  249. (define (initialize-weak-alist-pool) 
  250.   (return))
  251.  
  252. (define (get-weak-alist-vector size)
  253.   (cond ((fx= 0 size)
  254.          empty-weak-alist-vector)
  255.         (else
  256.          (make-vector size))))
  257.  
  258. (define (return-weak-alist-vector vec)
  259.   (let ((len (vector-length vec)))
  260.     (cond ((fx= 0 len))
  261.           (else
  262.            (vector-fill vec 0)))
  263.     (return)))
  264.  
  265. ;;; Weak Cells
  266.  
  267. (define (make-weak-cell contents)
  268.   (let ((wk (make-vector-extend header/weak-cell 0 1)))
  269.     (set (weak-cell-contents wk) contents)
  270.     wk))
  271.  
  272. (define-handler weak-cell
  273.   (object nil
  274. ;++    ((print self stream)
  275. ;++     (format stream "#{Weak-cell~_~D}" (object-hash self)))
  276.     ((crawl-exhibit self)
  277.      (exhibit-standard-extend self 1 0 0))
  278.     ((maybe-crawl-component self command)
  279.      (cond ((and (fixnum? command)
  280.                  (fx= command 0))
  281.             (crawl-push (extend-pointer-elt self command)))
  282.            (else nil)))
  283.     ((print-type-string self) "Weak-cell")))
  284.  
  285.  
  286. ;;; A population is like a list except that its members go away
  287. ;;; if they aren't copied out by the GC.  That is, at any point
  288. ;;; when the only way to get to an object is via a population, then
  289. ;;; the system is free to delete the object from the population,
  290. ;;; thus making it completely inaccessible.
  291.  
  292. ;;; The only valid operations on populations are:
  293. ;;; ADD-TO-POPULATION      - add an object to a population.
  294. ;;; REMOVE-FROM-POPULATION - remove an object from a population.
  295. ;;; POPULATION->LIST       - make a list of the members of a population.
  296. ;;;     (This has the effect of making the population's members
  297. ;;;     accessible via the returned list.)
  298.  
  299. (define (make-population id)
  300.   (ignore id)
  301.   (make-weak-set))
  302.  
  303. (define population? weak-set?)
  304.  
  305. (define add-to-population add-to-weak-set!)
  306.  
  307. (define remove-from-population remove-from-weak-set!)
  308.  
  309. (define population->list weak-set->list)
  310.  
  311. ;;; Auxiliary.  This is provided because it might for whatever reason
  312. ;;; be more efficient than (WALK PROC (POPULATION->LIST P)); e.g.
  313. ;;; there might be fewer pointers around if PROC does a GC.
  314.  
  315. ;++ shouldn't it be (WALK-POPULATION PROC P)
  316. (define (walk-population p proc)
  317.   (walk-weak-set proc p))
  318.